home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / misc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  21.8 KB  |  1,020 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* misc.c - miscellaneous programs */
  10.  
  11. #ifdef PALLOC
  12. #define calloc pcalloc
  13. #define free    pfree
  14. #define cfree    pcfree
  15. #define malloc    pmalloc
  16. #define realloc    prealloc
  17. #endif
  18.  
  19. #include "config.h"
  20. #include <stdlib.h>
  21. #include <stdio.h>
  22. #include <string.h>
  23. #include "time.h"
  24. #include "ifile.h"
  25. #include "miscprots.h"
  26.  
  27. #ifndef LIBDIR
  28. #define LIBDIR "/usr/local/lib"
  29. #endif
  30.  
  31. #ifdef vms
  32. #include <file.h>
  33. #include descrip
  34. #endif
  35.  
  36. #ifdef ADALIB
  37. #ifdef vms
  38. /*
  39. #include "adalib.h"
  40. */
  41. #endif
  42. #define EXIT_INTERNAL_ERROR
  43. #endif
  44.  
  45. #ifdef BINDER
  46. #ifdef vms
  47. /*
  48. #include "adabind.h"
  49. */
  50. #endif
  51. #define EXIT_INTERNAL_ERROR
  52. extern int adacomp_option;
  53. #endif
  54.  
  55. #ifdef INT
  56. #ifdef vms
  57. /*
  58. #include "adaexec.h"
  59. */
  60. #endif
  61. #define EXIT_INTERNAL_ERROR
  62. #endif
  63.  
  64. #ifndef EXPORT
  65. #undef EXIT_INTERNAL_ERROR
  66. #endif
  67. #ifdef BSD
  68. #include <sys/file.h>
  69. #endif
  70.  
  71. #ifdef vms
  72. char *DIRECTORY_START = "[.";    /* used as the beginning of a VMS dir spec. */
  73. #endif
  74.  
  75. char *LIBRARY_PREFIX= "";
  76.  
  77. /* PREDEFNAME gives directory path to predef files.
  78.  * libset() is used to toggle between libraries (the users and predef).
  79.  * tname = libset(lname) sets library prefix for ifopen, etc. to lname
  80.  * and returns prior setting in tname.
  81.  */
  82.  
  83. static void openerr(char *filename, char *mode);
  84. static void fhlist(IFILE *, char *);
  85.  
  86. #ifdef DEBUG
  87. #define IOT
  88. int malloctrace = 0;
  89. void trace_malloc()                                            /*;trace_malloc*/
  90. {
  91.     malloctrace = 1;
  92. }
  93. #endif
  94.  
  95. static int ifiles = 0;
  96.  
  97. #ifdef SMALLOC
  98. unsigned int smalloc_free = 0;
  99. char    *smalloc_ptr;
  100. #define SMALLOC_BLOCK 2000
  101. char **smalloc_table = (char **)0;
  102. unsigned smalloc_blocks = 0;
  103. #endif
  104.  
  105. char *smalloc(unsigned n)                                        /*;smalloc*/
  106. {
  107.     /* variant of malloc for use for blocks that will never be freed,
  108.      * primarily blocks used for small strings. This permits allocation
  109.      * in larger blocks avoiding the malloc overhead required for each block.
  110.      */
  111. #ifndef SMALLOC
  112.     return emalloct(n, "smalloc");
  113. #else
  114.     char *p;
  115.     if (n & 1) n+= 1;
  116. #ifdef ALIGN4
  117.     if (n & 2) n+= 2;
  118. #endif
  119.  
  120.     if (n > SMALLOC_BLOCK) { /* large block allocated separately */
  121. #ifdef DEBUG
  122.         printf("smalloc: warning block %u exceeds %d SMALLOC_BLOCK\n",
  123.           n, SMALLOC_BLOCK);
  124. #endif
  125.         p = emalloct(n, "smalloc");
  126.         return p;
  127.     }
  128.     if (n > smalloc_free) {
  129.         smalloc_ptr = emalloct(SMALLOC_BLOCK, "smalloc-block");
  130.         smalloc_free = SMALLOC_BLOCK;
  131.         smalloc_blocks++;
  132.         if (smalloc_blocks == 1) {
  133.             smalloc_table = (char **) emalloct(sizeof (char **),
  134.               "smalloc-table");
  135.         }
  136.         else { /* reallocate blocks */
  137.             smalloc_table = (char **) erealloct((char *)smalloc_table,
  138.               sizeof(char **) * (smalloc_blocks), "smalloc-table-realloc");
  139.         }
  140.         smalloc_table[smalloc_blocks-1] = smalloc_ptr;
  141.     }
  142.     p = smalloc_ptr;
  143.     smalloc_ptr += n;
  144.     smalloc_free -= n;
  145.     return p;
  146. #endif
  147. }
  148.  
  149. #ifdef DEBUG
  150. void smalloc_list()
  151. {
  152.     int i;
  153.     char **st;
  154.     st = smalloc_table;
  155.     for (i = 0; i < smalloc_blocks; i++) {
  156.         printf("%d %ld %x\n", i, *st, *st);
  157.         st++;
  158.     }
  159. }
  160. #endif
  161.  
  162. int is_smalloc_block(char *p)                            /*;is_smalloc_block*/
  163. {
  164.     /* returns TRUE is p points within block allocated by smalloc */
  165. #ifdef SMALLOC
  166. #ifdef IBM_PC
  167.     /* for PC need to do 32 bit pointer comparisons */
  168. /*
  169.     pragma off(segmented_pointer_operations);
  170. */
  171. #endif
  172.     int i;
  173.     char **st;
  174.  
  175.     st = smalloc_table;
  176.     if (smalloc_blocks == 0) chaos("is_malloc_block - no blocks");
  177.     for (i = 0; i < smalloc_blocks; i++) {
  178.         if (*st <= p && p  < (*st+(SMALLOC_BLOCK-1)))
  179.             return TRUE;
  180.         st++;
  181.     }
  182.     return FALSE;
  183. #ifdef IBM_PC
  184. /*
  185.     pragma on(segmented_pointer_operations);
  186. */
  187. #endif
  188. #else
  189.     return FALSE;
  190. #endif
  191. }
  192.  
  193. void capacity(char *s)                /*;capacity*/
  194. {
  195.     /* called  when compiler capacity limit exceeded.
  196.      * EXIT_INTERNAL_ERROR is defined when the module is run by itself
  197.      * (not spawned from adacomp) and DEBUG is not defined.
  198.      */
  199. #ifdef EXIT_INTERNAL_ERROR
  200. #ifdef vms
  201.     LIB$STOP(MSG_CAPACITY);
  202. #else
  203.     fprintf(stderr, "capacity limit exceeded: %s\n", s);
  204.     exitp(RC_INTERNAL_ERROR);
  205. #endif
  206. #else
  207. #ifdef DEBUG
  208.     printf("capacity limit exceeded: %s\nexecution abandoned \n", s);
  209. #endif
  210.     fprintf(stderr, "capacity limit exceeded: %s\n", s);
  211.     exitp(RC_INTERNAL_ERROR);
  212. #endif
  213. }
  214.  
  215. #ifdef CHAOS
  216. void chaos(char *s)                                                /*;chaos*/
  217. {
  218.     /* called when internal logic error detected and it is not meaningful
  219.      * to continue execution. This is never defined for the export version.
  220.      */
  221.     fprintf(stderr, "chaos: %s\nexecution abandoned \n", s);
  222.     printf("chaos: %s\nexecution abandoned \n", s);
  223.     exitp(RC_INTERNAL_ERROR);
  224. }
  225. #else
  226. void exit_internal_error()                        /*;exit_internal_error*/
  227. {
  228.     /* called when internal logic error detected and it is not meaningful
  229.      * to continue execution. This procedure is called by the export version.
  230.      * EXIT_INTERNAL_ERROR is defined when the module is run by itself
  231.      * (not spawned from adacomp) and EXPORT is defined.
  232.      * Now that adabind is a separate module which can be called by itself
  233.      * or spawned from adacomp, we must test the run time flag adacomp_option
  234.      * to determine which case it is.
  235.      */
  236. #ifdef EXIT_INTERNAL_ERROR
  237. #ifdef vms
  238.     LIB$STOP(MSG_CHAOS);
  239. #else
  240. #ifdef BINDER
  241.     if (adacomp_option)
  242. #endif
  243.         fprintf(stderr, "Adaed internal error - Please report.\n");
  244.     exit(RC_INTERNAL_ERROR);
  245. #endif
  246. #else
  247.     exit(RC_INTERNAL_ERROR);
  248. #endif
  249. }
  250. #endif
  251.  
  252. void exitp(int n)                                                /*;exitp*/
  253. {
  254.     /* synonym for exit() used so can trap exit() calls with debugger */
  255.     exit(n);
  256. }
  257.  
  258. char *ecalloc(unsigned nelem, unsigned nsize)            /*;ecalloc */
  259. {
  260.     /* calloc with error check if no more */
  261.  
  262.     char   *p;
  263.  
  264.     if (nelem > 20000) chaos("ecalloc: ridiculous argument");
  265.  
  266.     p = calloc (nelem, nsize);
  267.     if (p == (char *) 0)
  268.         capacity("out of memory \n");
  269.     return p;
  270. }
  271.  
  272. char *emalloc(unsigned n)                                        /*;emalloc */
  273. {    /* avoid BUGS - use calloc which presets result to zero  ds 3 dec 84*/
  274.     /* malloc with error check if no more */
  275.  
  276.     char   *p;
  277.  
  278.     if (n > 50000) chaos("emalloc: ridiculous argument");
  279.     p = calloc (1, n);
  280.     if (p == (char *) 0)
  281.         capacity("out of memory \n");
  282.     return (p);
  283. }
  284.  
  285. char *erealloc(char *ptr, unsigned size)                        /*;eralloc */
  286. {
  287.     /* realloc with error check if no more */
  288.  
  289.     char   *p;
  290.  
  291.     p = realloc (ptr, size);
  292.     if (p == (char *) 0)
  293.         capacity("erealloc: out of memory \n");
  294.     return (p);
  295. }
  296.  
  297. char *strjoin(char *s1, char *s2)                                /*;strjoin */
  298. {
  299.     /* return string obtained by concatenating argument strings
  300.      * watch for either argument being (char *)0 and treat this as null string
  301.      */
  302.  
  303.     char   *s;
  304.  
  305.     if (s1 == (char *)0) s1= "";
  306.     if (s2 == (char *)0) s2 = "";
  307.     s = smalloc((unsigned) strlen(s1) + strlen(s2) + 1);
  308.     strcpy(s, s1);
  309.     strcat(s, s2);
  310.     return s;
  311. }
  312.  
  313. int streq(char *a, char *b)                                            /*;streq*/
  314. {
  315.     /* test two strings for equality, allowing for null pointers */
  316.     if (a == (char *)0 && b == (char *)0)
  317.         return TRUE;
  318.     else if (a == (char *)0 || b == (char *)0)
  319.         return FALSE;
  320.     else return (strcmp(a, b) == 0);
  321. }
  322.  
  323. char *substr(char *s, int i, int j)                                /*;substr */
  324. {
  325.     /* return substring s(i..j) if defined, else return null ptr*/
  326.  
  327.     int    n;
  328.     char    *ts, *t;
  329.  
  330.     if (s == (char *)0) return (char *) 0;
  331.     n = strlen(s);
  332.     if (!(i > 0 && j <= n && i <= j)) return (char *)0;
  333.     /* allocate result, including null byte at end */
  334.     ts = smalloc((unsigned) j - i + 2);
  335.     t = ts;
  336.     s = s + (i - 1); /* point to start of source*/
  337.     for (; i <= j; i++) *t++ = *s++; /* copy characters */
  338.     *t = '\0'; /* terminate result */
  339.     return ts;
  340. }
  341.  
  342. /* getopt(3) procedure obtained from usenet */
  343. /*
  344.  * getopt - get option letter from argv
  345.  */
  346. #ifdef IBM_PC
  347. #define nogetopt
  348. #endif
  349.  
  350. #ifdef nogetopt
  351. char   *optarg;                /* Global argument pointer. */
  352. int    optind = 0;                /* Global argv index. */
  353.  
  354. static char *scan = NULL;    /* Private scan pointer. */
  355.  
  356. int getopt(int argc, char **argv, char *optstring)                /*;getopt */
  357. {
  358.     register char   c;
  359.     register char  *place;
  360.     optarg = NULL;
  361.  
  362.     if (scan == NULL || *scan == '\0') {
  363.         if (optind == 0)
  364.             optind++;
  365.  
  366.         if (optind >= argc || argv[optind][0] != '-' || argv[optind][1] == '\0')
  367.             return (EOF);
  368.         if (strcmp (argv[optind], "--") == 0) {
  369.             optind++;
  370.             return (EOF);
  371.         }
  372.  
  373.         scan = argv[optind] + 1;
  374.         optind++;
  375.     }
  376.  
  377.     c = *scan++;
  378.     place = strchr (optstring, c);
  379.  
  380.     if (place == NULL || c == ':') {
  381.         fprintf (stderr, "%s: unknown option -%c\n", argv[0], c);
  382.         return ('?');
  383.     }
  384.  
  385.     place++;
  386.     if (*place == ':') {
  387.         if (*scan != '\0') {
  388.             optarg = scan;
  389.             scan = NULL;
  390.         }
  391.         else {
  392.             optarg = argv[optind];
  393.             optind++;
  394.         }
  395.     }
  396.     return (c);
  397. }
  398. #endif
  399.  
  400. char *greentime(int un)                                        /*;greentime*/
  401. {
  402.     /* get greenwich time in string of 23 characters.
  403.      * format of result is as follows
  404.      *    1984 10 02 16 30 36 nnn
  405.      *    123456789a123456789b123
  406.      *    year mo da hr mi se uni
  407.      *
  408.      * greenwich time is used to avoid problems with daylight savings time.
  409.      * The last three characters are the compilation unit number
  410.      * (left filled with zeros if necessary).
  411.      * NOTE: changed to use local time to give approx. same time as
  412.      * SETL version            ds  20 nov 84
  413.      */
  414.  
  415.     char    *s;
  416. #ifndef IBM_PC
  417.     long clock;
  418. #else
  419.     /* IBM_PC (Metaware) */
  420.     time_t clock;
  421. #endif
  422.     /*struct tm *gmtime();*/
  423.     struct tm *t;
  424. #ifndef IBM_PC
  425.     clock = time(0);
  426. #else
  427.     time(&clock);
  428. #endif
  429.     s = smalloc(24);
  430.     /*t = gmtime(&clock);*/
  431.     t = localtime(&clock);
  432.     sprintf(s,"%04d %02d %02d %02d %02d %02d %03d",
  433. #ifdef IBM_PC
  434.       /* needed until Metaware fixes bug in tm_year field (ds 6-19-86) */
  435.       t->tm_year , t->tm_mon + 1, t->tm_mday,
  436. #else
  437.       t->tm_year + 1900, t->tm_mon + 1, t->tm_mday,
  438. #endif
  439.       t->tm_hour, t->tm_min, t->tm_sec, un);
  440.     return s;
  441. }
  442.  
  443. FILE *efopenl(char *filename, char *suffix, char *type, char *mode)    /*;efopenl*/
  444. {
  445.     char       *fname;
  446.     FILE       *f;
  447.  
  448.     fname = ifname(filename, suffix);
  449.     f =  efopen(fname, type, mode);
  450.     efree(fname);
  451.     return f;
  452. }
  453.  
  454. FILE *efopen(char *filename, char *type, char *mode)                /*;efopen*/
  455. {
  456.     FILE    *f;
  457. #ifdef IBM_PC
  458.     char    *p;
  459.     /* mode only meaningful for IBM PC for now */
  460.  
  461.     p = emalloc((unsigned) (strlen(type) + strlen(mode) + 1));
  462.     strcpy(p, type);
  463.     strcat(p, mode);
  464.     f = fopen(filename, p);
  465.     efree(p);
  466. #else
  467.     f = fopen(filename, type);
  468. #endif
  469.     if (f == (FILE *)0)
  470.         openerr(filename, type);
  471.     return f;
  472. }
  473.  
  474. void efree(char *p)                                                /*;efree*/
  475. {
  476.     /* free with check that not tryig to free null pointer*/
  477.     if (p == (char *)0)
  478.         chaos("efree: trying to free null pointer");
  479.     free(p);
  480. }
  481.  
  482. int strhash(char *s)                                        /*;strhash*/
  483. {
  484.     /* Hashing function from strings to numbers */
  485.  
  486.     register int hash = 0;
  487.  
  488.     /* add character values together, adding in the cumulative hash code
  489.      * at each step so that 'ABC' and 'BCA' have different hash codes.
  490.      */
  491.     while (*s)
  492.         hash += hash + *s++;
  493.     if (hash < 0) hash = - hash; /* to avoid negative hash code */
  494.     return hash;
  495. }
  496.  
  497. char *unit_name_type(char *u)                            /*;unit_name_type*/
  498. {
  499.     int    n;
  500.     char    *s;
  501.  
  502.     n = strlen(u);
  503.     if (n < 2) {
  504.         s = smalloc(1); 
  505.         *s = '\0'; 
  506.         return s;
  507.     }
  508.     /* otherwise, return first two characters */
  509.     s = smalloc(3);
  510.     s[0] = u[0];
  511.     s[1] = u[1];
  512.     s[2] = '\0';
  513.     return s;
  514. }
  515.  
  516. #ifdef BSD
  517. /* BSD doesn't support strchr() and strrchr(), but they are just
  518.  * named index() and rindex(), respectively, so here is code for BSD
  519.  */
  520. char *strchr(char *s, int c)
  521. {
  522.     return index(s, (char) c);
  523. }
  524.  
  525. char *strrchr(char *s, int c)
  526. {
  527.     return rindex(s, (char) c);
  528. }
  529. #endif
  530.  
  531. char *libset(char *lname)                                        /*;libset*/
  532. {
  533.     char *old_name;
  534.  
  535.     old_name = LIBRARY_PREFIX;
  536.     LIBRARY_PREFIX = lname;
  537.     return old_name;
  538. }
  539.  
  540. char *ifname(char *filename, char *suffix)                        /*;ifname*/
  541. {
  542.     char *fname;
  543.  
  544.     /* allow room for library prefix, file name and suffix */
  545. #ifdef vms
  546.     if (strchr(LIBRARY_PREFIX, '[')) {
  547.         fname = emalloc((unsigned) (strlen(LIBRARY_PREFIX) + 
  548.           strlen(filename) + strlen(suffix) + 2));
  549.     }
  550.     else {
  551.         fname = emalloc((unsigned) (strlen(LIBRARY_PREFIX) + 
  552.           strlen(filename) + strlen(suffix) + 3 + 2));
  553.     }
  554. #else
  555.     fname = emalloc((unsigned) (strlen(LIBRARY_PREFIX) + strlen(filename) +
  556.       strlen(suffix) + 3));
  557. #endif
  558.     if (strlen(LIBRARY_PREFIX)) { /* prepend library prefix if present */
  559. #ifdef vms
  560.         if (strchr(LIBRARY_PREFIX, '[')) {
  561.             strcpy(fname, LIBRARY_PREFIX);
  562.         }
  563.         else {
  564.             strcpy(fname, DIRECTORY_START);
  565.             strcat(fname, LIBRARY_PREFIX);
  566.         }
  567. #else
  568.         strcpy(fname, LIBRARY_PREFIX);
  569. #endif
  570. #ifdef IBM_PC
  571.         strcat(fname, "\\");
  572. #endif
  573. #ifdef BSD
  574.         strcat(fname, "/");
  575. #endif
  576. #ifdef SYSTEM_V
  577.         strcat(fname, "/");
  578. #endif
  579. #ifdef vms
  580.         if (!strchr(LIBRARY_PREFIX, '['))
  581.             strcat(fname, "]");
  582. #endif
  583.         strcat(fname, filename);
  584.     }
  585.     else {
  586.         strcpy(fname, filename); /* copy name if no prefix */
  587.     }
  588.     if (strlen(suffix)) {
  589.         strcat(fname, ".");
  590.         strcat(fname, suffix);
  591.     }
  592.     return fname;
  593. }
  594.  
  595. IFILE *ifopen(char *filename, char *suffix, char *mode, char *typea,
  596.   int trace, int pass)                                                /*;ifopen*/
  597. {
  598. #ifdef HI_LEVEL_IO
  599.     FILE  *file;
  600. #else
  601.     int      file;
  602.     int   flag;
  603. #endif
  604.     char  ftype, fversion, version;
  605.     char  type, modec;
  606.     char  *fname;
  607.     long  s = 0L;
  608.     int   nr, opened = FALSE, error = FALSE;
  609.     IFILE  *ifile;
  610. #ifdef IBM_PC
  611.     char *t_name;
  612. #endif
  613.  
  614.     type = typea[0]; 
  615.     modec= mode[0];
  616. #ifdef IOT
  617.     if (trace) {
  618.         printf("%s ", filename);
  619.     }
  620. #endif
  621.  
  622.     fname = ifname(filename, suffix); /* expand file name */
  623.  
  624. #ifdef IBM_PC
  625.     /* mode only meaningful for IBM PC for now */
  626.     t_name = emalloc((unsigned) (strlen(mode) + 2));
  627.     strcpy(t_name, mode);
  628.     strcat(t_name, "b");
  629.     file = fopen(fname, t_name);
  630.     efree(t_name);
  631. #else
  632. #ifdef HI_LEVEL_IO
  633.     file = fopen(fname, mode);
  634. #else
  635. #ifdef vms
  636.     if (modec == 'w') {
  637.         while(~delete(strjoin(fname, ";")));
  638.     }
  639. #endif
  640.     if (mode[0] == 'w' || mode[1] == '+') {
  641.         flag = O_CREAT | O_RDWR;
  642.     }
  643.     else {
  644.         /* ASSUMING only other possibility  is "r" !! */
  645.         flag = O_RDONLY;
  646.     }
  647.     file = open(fname, flag, 0700);
  648. #endif
  649. #endif
  650.  
  651. #ifdef HI_LEVEL_IO
  652.     if (file == (FILE *)0) {
  653. #else
  654.     if (file == -1) {
  655. #endif
  656.         if (pass)
  657.             return (IFILE *) 0;
  658.         else
  659.             openerr(fname, mode);
  660.     }
  661.     ifile = (IFILE *) emalloc(sizeof(IFILE));
  662.     version = (type == 'a') ? AIS_VERSION : (type == 't') ? TRE_VERSION :
  663.       (type == 'l') ? LIB_VERSION : (type == 's') ? STUB_VERSION :  
  664.       (type == 'p') ? AST_VERSION : '?';
  665.     ifiles++;
  666.     if (modec == 'w') { /* write header */
  667.         /* write long at start to later be replaced with slots offset */
  668.         ifile->fh_mode = modec;
  669.         ifile->fh_type = type;
  670.         ifile->fh_version = version;
  671.         ifile->fh_slots = 0;
  672.         ifile->fh_units_end = 0;
  673. #ifdef HI_LEVEL_IO
  674.         /* will be upated on close */
  675.         fwrite((char *) ifile, sizeof(IFILE), 1, file);
  676. #else
  677.         write(file, (char *)ifile, sizeof(IFILE));
  678. #endif
  679.     }
  680.     else if (modec == 'r') { /* read and check header */
  681. #ifdef HI_LEVEL_IO
  682.         nr = fread((char *) ifile, sizeof(IFILE), 1, file);
  683. #else
  684.         nr = read(file, (char *) ifile, sizeof(IFILE));
  685. #endif
  686.  
  687. #ifdef HI_LEVEL_IO
  688.         if (nr != 1) {
  689. #else
  690.         if (nr != sizeof(IFILE)) {
  691. #endif
  692. #ifdef DEBUG
  693.             printf("ifopen - unable to read header\n");
  694. #endif
  695.             error = TRUE;
  696.         }
  697.         ftype = ifile->fh_type;
  698.         if (!error &&  ftype != type) {
  699. #ifdef DEBUG
  700.             printf("ifopen read wrong type\n");
  701. #endif
  702.             error = TRUE;
  703.         }
  704.         fversion = ifile->fh_version;
  705.         if (!error && fversion != version) {
  706. #ifdef DEBUG
  707.             printf("open file read wrong version\n");
  708. #endif
  709.             error = TRUE;
  710.         }
  711.     }
  712.     if (error) {
  713.         openerr(fname, mode);
  714.     }
  715.     ifile->fh_number = ifiles;/* set count so can match open and close*/
  716.     ifile->fh_trace = trace;
  717.     ifile->fh_file = file;
  718.     ifile->fh_mode = modec;
  719.  
  720. #ifdef DEBUG
  721.     if (ifile->fh_trace) fhlist(ifile, "open");
  722. #endif
  723.     efree(fname);
  724.     return ifile;
  725. }
  726.  
  727. static void openerr(char *filename, char *mode)                    /*;openerr*/
  728. {
  729.     /* EXIT_INTERNAL_ERROR is defined when the module is run by itself
  730.      * (not spawned from adacomp) and DEBUG is not defined.
  731.      */
  732. #ifdef EXIT_INTERNAL_ERROR
  733. #ifdef vms
  734.     struct dsc$descriptor_s file_name;
  735.     file_name.dsc$w_length = strlen(filename);
  736.     file_name.dsc$b_dtype = DSC$K_DTYPE_T;
  737.     file_name.dsc$b_class = DSC$K_CLASS_S;
  738.     file_name.dsc$a_pointer = filename;
  739.     LIB$SIGNAL(MSG_NOTOPEN, 1, &file_name);
  740.     exit();
  741. #else
  742.     fprintf(stderr, "Unable to open file %s for %s \n", filename,
  743.       (strcmp(mode, "w") == 0 ? "writing"
  744.       : (strcmp(mode, "r") == 0 ? "reading"
  745.       : (strcmp(mode, "a") == 0 ? "appending"
  746.       :  mode))));
  747.     exit(RC_ABORT);
  748. #endif
  749. #else
  750.     fprintf(stderr, "Unable to open file %s for %s \n", filename,
  751.       (strcmp(mode, "w") == 0 ? "writing"
  752.       : (strcmp(mode, "r") == 0 ? "reading"
  753.       : (strcmp(mode, "a") == 0 ? "appending"
  754.       :  mode))));
  755.     exit(RC_ABORT);
  756. #endif
  757. }
  758.  
  759. void ifclose(IFILE *ifile)                                    /*;ifclose*/
  760. {
  761. #ifdef HI_LEVEL_IO
  762.     FILE *file;
  763. #else
  764.     int  file;
  765. #endif
  766.  
  767. #ifdef DEBUG
  768.     if (ifile->fh_trace) fhlist(ifile, "close");
  769. #endif
  770.  
  771.     file = ifile->fh_file;
  772.     /* write out file header if write mode */
  773.     if (ifile->fh_mode == 'w') {
  774.         ifile->fh_trace = 0; /* trace and number fields internal use only */
  775.         ifile->fh_number = 0;
  776.         ifile->fh_mode = '\0';
  777.         ifseek(ifile, "update-header", 0L, 0);
  778. #ifdef HI_LEVEL_IO
  779.         fwrite((char *)ifile, sizeof(IFILE), 1, file);
  780. #else
  781.         write(file, (char *)ifile, sizeof(IFILE));
  782. #endif
  783.     }
  784. #ifdef HI_LEVEL_IO
  785.     if (file == (FILE *)0)
  786.         chaos("ifclose: closing unopened file");
  787.     fclose(file);
  788.     ifile->fh_file = (FILE *)0;
  789. #else
  790.     if (file== -1)
  791.         chaos("ifclose: closing unopened file");
  792.     close(file);
  793.     ifile->fh_file = 0;
  794. #endif
  795. }
  796.  
  797. void ifoclose(IFILE *ifile)                                    /*;ifoclose*/
  798. {
  799.     /* close file if still open */
  800. #ifdef HI_LEVEL_IO
  801.     if (ifile != (IFILE *) 0 && ifile->fh_file != (FILE *) 0) {
  802. #else
  803.     if (ifile != (IFILE *) 0 && ifile->fh_file != 0) {
  804. #endif
  805.         ifclose(ifile);
  806.     }
  807. }
  808.  
  809. #ifdef DEBUG
  810. static void fhlist(IFILE *ifile, char *desc)                        /*;fhlist*/
  811. {
  812.     /* list file header if tracing */
  813.     printf("%s %c %d%c  version %c trace %d", desc, ifile->fh_mode,
  814.       ifile->fh_number, ifile->fh_type, ifile->fh_version, ifile->fh_trace);
  815.     printf(" slots %ld units_end %ld\n", ifile->fh_slots, ifile->fh_units_end);
  816. }
  817. #endif
  818.  
  819. long ifseek(IFILE *ifile, char *desc, long offset, int ptr)        /*;ifseek*/
  820. {
  821.     long begpos, endpos, seekval;
  822.     begpos = iftell(ifile);
  823. #ifdef HI_LEVEL_IO
  824.     seekval = fseek(ifile->fh_file, offset, ptr);
  825. #else
  826.     seekval = lseek(ifile->fh_file, offset, ptr);
  827. #endif
  828.     if (seekval == -1) chaos("ifseek: improper seek");
  829.  
  830.     endpos = iftell(ifile);
  831. #ifdef IOT
  832.     if (ifile->fh_trace > 1 )
  833.         printf("%s seek %d%c from %ld to %ld\n", desc,
  834.           ifile->fh_number, ifile->fh_type, begpos, endpos);
  835. #endif
  836.     return endpos;
  837. }
  838.  
  839. long iftell(IFILE *ifile)                                    /*;iftell*/
  840. {
  841.     /* ftell, but arg is IFILE */
  842. #ifdef HI_LEVEL_IO
  843.     return ftell(ifile->fh_file);
  844. #else
  845.     return lseek(ifile->fh_file, 0, 1);
  846. #endif
  847. }
  848.  
  849. /* define MEAS_ALLOC to measure alloc performance */
  850. #define MEAS_ALLOC
  851. /* this causes each malloc action to write a line to standard output
  852.  * formatted as follows:
  853.  * code:one of a, r, f
  854.  * a    allocate block
  855.  * r    reallocate block
  856.  * f    free block
  857.  * the block address (integer)
  858.  * the block length (or zero if not applicable)
  859.  * the remainder of the line describes the action
  860.  */
  861.  
  862. extern FILE *MALFILE;
  863.  
  864. #ifndef EXPORT
  865. char *emalloct(unsigned n, char *s)                                /*;emalloct*/
  866. {
  867.     char *p;
  868.     p = emalloc(n);
  869. #ifdef DEBUG
  870.     if (malloctrace) fprintf(MALFILE, "a %ld %u %s\n", p, n, s);
  871. #endif
  872.     return p;
  873. }
  874. #endif
  875.  
  876. #ifndef EXPORT
  877. char *malloct(unsigned n, char *s)        /*;malloct*/
  878. {
  879.     /* like emalloct, but ok if not able to allocate block */
  880.     char *p;
  881.     p = malloc(n);
  882. #ifdef DEBUG
  883.     if (p != (char *)0 && malloctrace)
  884.         fprintf(MALFILE, "a %ld %u %s\n", p, n, s);
  885. #endif
  886.     return p;
  887. }
  888. #endif
  889.  
  890. #ifndef EXPORT
  891. char *ecalloct(unsigned n, unsigned m, char *msg)
  892. {
  893.     char *p;
  894.     p = ecalloc(n, m);
  895. #ifdef DEBUG
  896.     if (malloctrace) fprintf(MALFILE, "a %ld %u %s\n", p, n*m, msg);
  897. #endif
  898.     return p;
  899. }
  900. #endif
  901.  
  902. #ifndef EXPORT
  903. char *erealloct(char *ptr, unsigned size, char *msg)        /*;erealloct*/
  904. {
  905.     char *p;
  906.     p = erealloc(ptr, size);
  907. #ifdef DEBUG
  908.     if (p == ptr) return p;
  909.     if (malloctrace)  /* trace line includes old address before msg */
  910.         fprintf(MALFILE, "r %ld %u %ld %s\n", p, size, ptr, msg);
  911. #endif
  912.     return p;
  913. }
  914. #endif
  915.  
  916. #ifndef EXPORT
  917. void efreet(char *p, char *msg)                                    /*;efreet*/
  918. {
  919. #ifdef DEBUG
  920.     if (malloctrace) fprintf(MALFILE, "f %ld 0 %s\n", p, msg);
  921. #endif
  922.     efree(p);
  923. }
  924. #endif
  925.  
  926. char *predef_env()            /*;predef_env*/
  927. {
  928. #ifndef IBM_PC
  929.     char *s = getenv("ADAEDPREDEF");
  930.     if (s == (char *)0) s = get_libdir();
  931.     return s;
  932. #else
  933.     char *getenv();
  934.     return getenv("ADAED");
  935. #endif
  936. }
  937.  
  938. char *get_libdir()
  939. {
  940.     char *s = getenv("ADAED");
  941.     if (s == (char *)0)
  942.         return LIBDIR;
  943.     else
  944.         return s;
  945. }
  946.  
  947. char *parsefile(char *s, int *np, int *nb, int *ns)                /*;parsefile*/
  948. {
  949.     /* Parse file name s, returning the length of prefix, base part, and
  950.      * suffix in np, nb, and nl, respectively. A pointer to the start of
  951.      * the base part is returned, or the null pointer if no base part.
  952.      * The suffix is assumed to begin with period.
  953.      * The prefix ends with the last instance of any of the prefix characters.
  954.      */
  955.  
  956. #ifdef IBM_PC
  957.     char   *prefix_chars = ":/\\";
  958. #endif
  959. #ifdef BSD
  960.     char   *prefix_chars = "/";
  961. #endif
  962. #ifdef SYSTEM_V
  963.     char   *prefix_chars = "/";
  964. #endif
  965. #ifdef vms
  966.     char   *prefix_chars = ":[]";
  967. #endif
  968.     int    n,i;
  969.     char   *pb;
  970.     char   *p, *p2;
  971.     char   *suffix_chars = ".";
  972.     int    have_prefix = 0;
  973.  
  974.     n = strlen(s);
  975.     pb = s; /* assume name starts with base */
  976.     *ns = 0;
  977.     p = s + n; /* point to last (null) character in s */
  978.     /* find length of suffix */
  979.     /* but if find a prefix character first, then no suffix possible */
  980.     for (i = n - 1; i >= 0; i--) {
  981.         p--; 
  982.         for (p2 = prefix_chars; *p2 !='\0';) {
  983.             if (*p == *p2++) {
  984.                  /* (p-s) gives number of characters before suffix */
  985.                  have_prefix = 1;
  986.                  break;
  987.             }
  988.         }
  989.         if (!have_prefix) {
  990.             for (p2 = suffix_chars; *p2 !='\0';) {
  991.                 if (*p == *p2++) {
  992.                      /* (p-s) gives number of characters before suffix */
  993.                      *ns = n - (p - s);
  994.                      break;
  995.                 }
  996.             }
  997.         }
  998.     }
  999.     /* find length of prefix */
  1000.     *np = 0;
  1001.     p = s + n;
  1002.     for (i = n - 1; i >= 0; i--) {
  1003.         p--; 
  1004.         for (p2 = prefix_chars; *p2 !='\0';) {
  1005.             if (*p == *p2++) {
  1006.                  p++; /* include last delimiter in prefix */
  1007.                  /* (p-s) now gives prefix length*/
  1008.                  *np = (p - s);
  1009.                  pb = p;
  1010.                  break;
  1011.             }
  1012.         }
  1013.     }
  1014.     /* base is what remains after removing prefix and suffix*/
  1015.     *nb = n - (*np + *ns);
  1016.     if (*nb == 0)
  1017.         pb = (char *)0; /* if no base */
  1018.     return pb;
  1019. }
  1020.